home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / code / lispinit.lisp < prev    next >
Encoding:
Text File  |  1992-05-30  |  10.6 KB  |  348 lines
  1. ;;; -*- Mode: Lisp; Package: Lisp; Log: code.log -*-
  2. ;;;
  3. ;;; **********************************************************************
  4. ;;; This code was written as part of the CMU Common Lisp project at
  5. ;;; Carnegie Mellon University, and has been placed in the public domain.
  6. ;;; If you want to use this code or any part of CMU Common Lisp, please contact
  7. ;;; Scott Fahlman or slisp-group@cs.cmu.edu.
  8. ;;;
  9. (ext:file-comment
  10.   "$Header: lispinit.lisp,v 1.31.2.1 92/03/26 03:22:33 wlott Exp $")
  11. ;;;
  12. ;;; **********************************************************************
  13. ;;;
  14. ;;; Initialization stuff for CMU Common Lisp, plus some other random functions
  15. ;;; that we don't have any better place for.
  16. ;;; 
  17. ;;; Written by Skef Wholey and Rob MacLachlan.
  18. ;;;
  19. (in-package "LISP" :use '("SYSTEM" "DEBUG"))
  20.  
  21. (export '(most-positive-fixnum most-negative-fixnum sleep
  22.       ++ +++ ** *** // ///))
  23.  
  24. (in-package "SYSTEM" :nicknames '("SYS"))
  25. (export '(compiler-version scrub-control-stack))
  26.  
  27. (in-package "EXTENSIONS")
  28. (export '(quit *prompt*))
  29.  
  30. (in-package "LISP")
  31.  
  32. ;;; Make the error system enable interrupts.
  33.  
  34. (defconstant most-positive-fixnum #.vm:target-most-positive-fixnum
  35.   "The fixnum closest in value to positive infinity.")
  36.  
  37. (defconstant most-negative-fixnum #.vm:target-most-negative-fixnum
  38.   "The fixnum closest in value to negative infinity.")
  39.  
  40.  
  41. ;;; Random information:
  42.  
  43. (defvar *lisp-implementation-version* "4.0(?)")
  44.  
  45.  
  46. ;;; Must be initialized in %INITIAL-FUNCTION before the DEFVAR runs...
  47. (proclaim '(special *gc-inhibit* *already-maybe-gcing*
  48.             *need-to-collect-garbage* *gc-verbose*
  49.             *before-gc-hooks* *after-gc-hooks*
  50.             unix::*interrupts-enabled*
  51.             unix::*interrupt-pending*
  52.             c::*type-system-initialized*))
  53.  
  54.  
  55. ;;;; Random magic specials.
  56.  
  57.  
  58. ;;; These are filled in by Genesis.
  59.  
  60. (defvar *current-catch-block*)
  61. (defvar *current-unwind-block*)
  62. (defvar *free-interrupt-context-index*)
  63.  
  64.  
  65.  
  66. ;;; %Initial-Function is called when a cold system starts up.  First we zoom
  67. ;;; down the *Lisp-Initialization-Functions* doing things that wanted to happen
  68. ;;; at "load time."  Then we initialize the various subsystems and call the
  69. ;;; read-eval-print loop.  The top-level Read-Eval-Print loop is executed until
  70. ;;; someone (most likely the Quit function) throws to the tag
  71. ;;; %End-Of-The-World.  We quit this way so that all outstanding cleanup forms
  72. ;;; in Unwind-Protects will get executed.
  73.  
  74. (proclaim '(special *lisp-initialization-functions*
  75.             *load-time-values*))
  76.  
  77. (eval-when (compile)
  78.   (defmacro print-and-call (name)
  79.     `(progn
  80.        (%primitive print ,(symbol-name name))
  81.        (,name))))
  82.  
  83. (defun %initial-function ()
  84.   "Gives the world a shove and hopes it spins."
  85.   (setf *already-maybe-gcing* t)
  86.   (setf *gc-inhibit* t)
  87.   (setf *need-to-collect-garbage* nil)
  88.   (setf *gc-verbose* t)
  89.   (setf *before-gc-hooks* nil)
  90.   (setf *after-gc-hooks* nil)
  91.   (setf unix::*interrupts-enabled* t)
  92.   (setf unix::*interrupt-pending* nil)
  93.   (setf c::*type-system-initialized* nil)
  94.   (%primitive print "In initial-function, and running.")
  95.  
  96.   ;; Many top-level forms call INFO, (SETF INFO).
  97.   (print-and-call c::globaldb-init)
  98.  
  99.   ;; Some of the random top-level forms call Make-Array, which calls Subtypep...
  100.   (print-and-call type-init)
  101.  
  102.   (let ((funs (nreverse *lisp-initialization-functions*)))
  103.     (%primitive print "Calling top-level forms.")
  104.     (dolist (fun funs)
  105.       (typecase fun
  106.     (function
  107.      (funcall fun))
  108.     (cons
  109.      (case (car fun)
  110.        (:load-time-value
  111.         (setf (svref *load-time-values* (third fun)) 
  112.           (funcall (second fun))))
  113.        (:load-time-value-fixup
  114.         (setf (sap-ref-32 (second fun) 0)
  115.           (get-lisp-obj-address
  116.            (svref *load-time-values* (third fun)))))
  117.        (t
  118.         (%primitive print
  119.             "Bogus fixup in *lisp-initialization-functions*")
  120.         (%halt))))
  121.     (t
  122.      (%primitive print
  123.              "Bogus function in *lisp-initialization-functions*")
  124.      (%halt)))))
  125.   (makunbound '*lisp-initialization-functions*)    ; So it gets GC'ed.
  126.   (makunbound '*load-time-values*)
  127.  
  128.   ;; Only do this after top level forms have run, 'cause thats where
  129.   ;; deftypes are.
  130.   (setf c::*type-system-initialized* t)
  131.  
  132.   (print-and-call os-init)
  133.   (print-and-call filesys-init)
  134.  
  135.   (print-and-call reader-init)
  136.   (print-and-call backq-init)
  137.   (print-and-call sharp-init)
  138.   ;; After the various reader subsystems have done their thing to the standard
  139.   ;; readtable, copy it to *readtable*.
  140.   (setf *readtable* (copy-readtable std-lisp-readtable))
  141.  
  142.   (print-and-call stream-init)
  143.   (print-and-call loader-init)
  144.   (print-and-call package-init)
  145.   (print-and-call kernel::signal-init)
  146.   (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
  147.   (set-floating-point-modes :traps '(:overflow :underflow :invalid
  148.                            :divide-by-zero))
  149.   ;; This is necessary because some of the initial top level forms might
  150.   ;; have changed the compliation policy in strange ways.
  151.   (print-and-call c::proclaim-init)
  152.  
  153.   (%primitive print "Done initializing.")
  154.  
  155.   (setf *already-maybe-gcing* nil)
  156.   (terpri)
  157.   (princ "CMU Common Lisp kernel core image ")
  158.   (princ (lisp-implementation-version))
  159.   (princ ".")
  160.   (terpri)
  161.   (princ "[You are in the LISP package.]")
  162.   (terpri)
  163.   (catch '%end-of-the-world
  164.     (loop
  165.      (%top-level)
  166.      (write-line "You're certainly a clever child.")))
  167.   (unix:unix-exit 0))
  168.  
  169.  
  170. ;;;; Initialization functions:
  171.  
  172. (defun reinit ()
  173.   (without-interrupts
  174.    (without-gcing
  175.     (os-init)
  176.     (stream-reinit)
  177.     (kernel::signal-init)
  178.     (gc-init)
  179.     (setf (alien:extern-alien "internal_errors_enabled" alien:boolean) t)
  180.     (set-floating-point-modes :traps
  181.                   '(:overflow :underflow :invalid
  182.                       :divide-by-zero)))))
  183.  
  184.  
  185.  
  186. ;;;; Miscellaneous external functions:
  187.  
  188. ;;; Quit gets us out, one way or another.
  189.  
  190. (defun quit (&optional recklessly-p)
  191.   "Terminates the current Lisp.  Things are cleaned up unless Recklessly-P is
  192.   non-Nil."
  193.   (if recklessly-p
  194.       (unix:unix-exit 0)
  195.       (throw '%end-of-the-world nil)))
  196.  
  197.  
  198. (defun sleep (n)
  199.   "This function causes execution to be suspended for N seconds.  N may
  200.   be any non-negative, non-complex number."
  201.   (when (or (not (realp n))
  202.         (minusp n))
  203.     (error "Invalid argument to SLEEP: ~S.~%~
  204.             Must be a non-negative, non-complex number."
  205.        n))
  206.   (multiple-value-bind (sec usec)
  207.                (if (integerp n)
  208.                (values n 0)
  209.                (values (truncate n)
  210.                    (truncate (* n 1000000))))
  211.     (unix:unix-select 0 0 0 0 sec usec))
  212.   nil)
  213.  
  214.  
  215. ;;;; SCRUB-CONTROL-STACK
  216.  
  217.  
  218. (defconstant bytes-per-scrub-unit 2048)
  219.  
  220. (defun scrub-control-stack ()
  221.   "Zero the unused portion of the control stack so that old objects are not
  222.    kept alive because of uninitialized stack variables."
  223.   (declare (optimize (speed 3) (safety 0))
  224.        (values (unsigned-byte 20)))
  225.   (labels
  226.       ((scrub (ptr offset count)
  227.      (declare (type system-area-pointer ptr)
  228.           (type (unsigned-byte 16) offset)
  229.           (type (unsigned-byte 20) count)
  230.           (values (unsigned-byte 20)))
  231.      (cond ((= offset bytes-per-scrub-unit)
  232.         (look (sap+ ptr bytes-per-scrub-unit) 0 count))
  233.            (t
  234.         (setf (sap-ref-32 ptr offset) 0)
  235.         (scrub ptr (+ offset vm:word-bytes) count))))
  236.        (look (ptr offset count)
  237.      (declare (type system-area-pointer ptr)
  238.           (type (unsigned-byte 16) offset)
  239.           (type (unsigned-byte 20) count)
  240.           (values (unsigned-byte 20)))
  241.      (cond ((= offset bytes-per-scrub-unit)
  242.         count)
  243.            ((zerop (sap-ref-32 ptr offset))
  244.         (look ptr (+ offset vm:word-bytes) count))
  245.            (t
  246.         (scrub ptr offset (+ count vm:word-bytes))))))
  247.     (let* ((csp (sap-int (c::control-stack-pointer-sap)))
  248.        (initial-offset (logand csp (1- bytes-per-scrub-unit))))
  249.       (declare (type (unsigned-byte 32) csp))
  250.       (scrub (int-sap (- csp initial-offset))
  251.          (* (floor initial-offset vm:word-bytes) vm:word-bytes)
  252.          0))))
  253.  
  254.  
  255.  
  256. ;;;; TOP-LEVEL loop.
  257.  
  258. (defvar / nil
  259.   "Holds a list of all the values returned by the most recent top-level EVAL.")
  260. (defvar // nil "Gets the previous value of / when a new value is computed.")
  261. (defvar /// nil "Gets the previous value of // when a new value is computed.")
  262. (defvar * nil "Holds the value of the most recent top-level EVAL.")
  263. (defvar ** nil "Gets the previous value of * when a new value is computed.")
  264. (defvar *** nil "Gets the previous value of ** when a new value is computed.")
  265. (defvar + nil "Holds the value of the most recent top-level READ.")
  266. (defvar ++ nil "Gets the previous value of + when a new value is read.")
  267. (defvar +++ nil "Gets the previous value of ++ when a new value is read.")
  268. (defvar - nil "Holds the form curently being evaluated.")
  269. (defvar *prompt* "* "
  270.   "The top-level prompt string.  This also may be a function of no arguments
  271.    that returns a simple-string.")
  272. (defvar *in-top-level-catcher* nil
  273.   "True if we are within the Top-Level-Catcher.  This is used by interrupt
  274.   handlers to see whether it is o.k. to throw.")
  275.  
  276. (defun interactive-eval (form)
  277.   "Evaluate FORM, returning whatever it returns but adjust ***, **, *, +++, ++,
  278.   +, ///, //, /, and -."
  279.   (setf - form)
  280.   (let ((results (multiple-value-list (eval form))))
  281.     (setf /// //
  282.       // /
  283.       / results
  284.       *** **
  285.       ** *
  286.       * (car results)))
  287.   (setf +++ ++
  288.     ++ +
  289.     + -)
  290.   (unless (boundp '*)
  291.     ;; The bogon returned an unbound marker.
  292.     (setf * nil)
  293.     (cerror "Go on with * set to NIL."
  294.         "EVAL returned an unbound marker."))
  295.   (values-list /))
  296.  
  297.  
  298. (defconstant eofs-before-quit 10)
  299.  
  300. (defun %top-level ()
  301.   "Top-level READ-EVAL-PRINT loop.  Do not call this."
  302.   (let  ((* nil) (** nil) (*** nil)
  303.      (- nil) (+ nil) (++ nil) (+++ nil)
  304.      (/// nil) (// nil) (/ nil)
  305.      (magic-eof-cookie (cons :eof nil))
  306.      (number-of-eofs 0))
  307.     (loop
  308.       (with-simple-restart (abort "Return to Top-Level.")
  309.     (catch 'top-level-catcher
  310.       (unix:unix-sigsetmask 0)
  311.       (let ((*in-top-level-catcher* t))
  312.         (loop
  313.           (scrub-control-stack)
  314.           (fresh-line)
  315.           (princ (if (functionp *prompt*)
  316.              (funcall *prompt*)
  317.              *prompt*))
  318.           (force-output)
  319.           (let ((form (read *standard-input* nil magic-eof-cookie)))
  320.         (cond ((not (eq form magic-eof-cookie))
  321.                (let ((results
  322.                   (multiple-value-list (interactive-eval form))))
  323.              (dolist (result results)
  324.                (fresh-line)
  325.                (prin1 result)))
  326.                (setf number-of-eofs 0))
  327.               ((eql (incf number-of-eofs) 1)
  328.                (let ((stream (make-synonym-stream '*terminal-io*)))
  329.              (setf *standard-input* stream)
  330.              (setf *standard-output* stream)
  331.              (format t "~&Received EOF on *standard-input*, ~
  332.                     switching to *terminal-io*.~%")))
  333.               ((> number-of-eofs eofs-before-quit)
  334.                (format t "~&Received more than ~D EOFs; Aborting.~%"
  335.                    eofs-before-quit)
  336.                (quit))
  337.               (t
  338.                (format t "~&Received EOF.~%")))))))))))
  339.  
  340.  
  341.  
  342. ;;; %Halt  --  Interface
  343. ;;;
  344. ;;;    A convenient way to get into the assembly level debugger.
  345. ;;;
  346. (defun %halt ()
  347.   (%primitive halt))
  348.